

open GL
open Glu
open Glut

type screen = Game | Menu
let activeScreen = ref Menu

module Client = 
  struct
    (* Obj.magic trick, do not use
     * before initialization (segmentation fault),
     * could be set to stdin, stdout, but often we
     * do not have objects of the type needed *)
    let in_channel = ref (Obj.magic 0)
    let out_channel = ref (Obj.magic 0)

    exception WouldBlock
    let connected = ref false

    (* command buffer *)
    let cmdBuffer = Buffer.create 256
    let cmdAdd cmd = (* new commands have to be properly escaped *)
      Buffer.add_string cmdBuffer 
	((Types.Data.show (Types.Data.String cmd))^" ") 

    (* state buffer *)
    let state = ref ((-1,                    (* player id     *)
		      Types.Data.Float 0.0), (* player hp     *)
		     (Types.Data.List [],    (* player list   *)
		      Types.Data.List [],    (* object list   *)
		      Types.Data.List []))    (* player scores *)
    let playerId () = match !state with  (playerId, _), _  -> playerId
    let playerHp () = match !state with  (_, playerHp), _  -> playerHp
    let players ()  = match !state with _, (players, _, _) -> players
    let objects ()  = match !state with _, (_, objects, _) -> objects
    let score ()    = match !state with _, (_, _, score)   -> score
      
    module Hud =
      struct
	let scoreTableActive = ref false
	let scoreTable x = Widgets.table (0.02, 0.02) (0.96, 0.96) 
	  (1.0, 1.0, 1.0, 0.2)
	  (1.0, 1.0, 1.0, 1.0) (0.8, 0.8, 0.8, 0.2) 
	  GLUT_BITMAP_HELVETICA_10 ([Types.Data.String "Player";
				     Types.Data.String "Frags";
				     Types.Data.String "Deaths"]::x)
	let healthBar = 
	  Widgets.bar (0.85, 0.92) (0.1, 0.02) Types.green !Config.maxHP
	let health = Widgets.label (0.85, 0.95) 
	  Types.green GLUT_BITMAP_HELVETICA_18
	  
	let draw () =
	  healthBar (playerHp ());
	  health (playerHp ());
	  if !scoreTableActive then
	    let () = match score () with
	      | Types.Data.List ls -> 
		scoreTable (List.map Types.Data.to_list ls)
	      | _ -> assert false in ()	
      end

    (* establish the connection *)
    let openConnection server port = 
      let ip = (Unix.gethostbyname server).Unix.h_addr_list.(0) in
      let addr = Unix.ADDR_INET(ip, port) in
      let inc, outc = Unix.open_connection addr in
      let descr = Unix.descr_of_out_channel outc in      
      let () = Unix.setsockopt descr Unix.TCP_NODELAY true in (* duh *)
      let () = in_channel := inc in
      let () = out_channel := outc in
      connected := true;
      ()

    (* send command *)
    let send buffer = 
      let descr = Unix.descr_of_out_channel !out_channel in
      match Unix.getsockopt_error descr with
	| None ->
	    let () = Buffer.add_char buffer '\n' in
	    let () = Buffer.output_buffer !out_channel buffer in
	    let () = flush !out_channel in
	    ()
	| Some error ->
	    let () = connected := false in
	    let () = print_endline (Unix.error_message error) in
	    () (* TODO: add fancy error messages *)

    (* receive return value, non-blocking *)
    let recv () =
      let descr = Unix.descr_of_in_channel !in_channel in
      let in_files, _, _ = Unix.select [descr] [] [] 0.0 in 
      match in_files with
	| [] -> raise WouldBlock (* in_channel not ready to read *)
	| _  -> Marshal.from_channel !in_channel

    let finalize () = 
      if !connected then
	begin
	  connected := false;
	  let () = Unix.shutdown_connection !in_channel in
	  ()
	end
      else ()

    (* loop recv until the latest game state possible is obtained *)
    let getState () =
      let rec getObjects newState =
	try getObjects (recv ())
	with WouldBlock -> newState in 
      try
	state := getObjects (!state)
      with _ -> ()

    let updateState () =
      if not !connected then () else 
      begin
	send cmdBuffer;
	getState ();
	Buffer.clear cmdBuffer 
      end

    let special ~key ~x ~y =
      match key with
	| GLUT_KEY_UP    -> cmdAdd "+Up" 
	| GLUT_KEY_LEFT  -> cmdAdd "+Left" 
	| GLUT_KEY_RIGHT -> cmdAdd "+Right" 
	| GLUT_KEY_DOWN  -> cmdAdd "+Down"
	| _ -> ()

    let specialUp key x y = 
   	match key with
	| GLUT_KEY_UP    -> cmdAdd "-Up" 
	| GLUT_KEY_LEFT  -> cmdAdd "-Left" 
	| GLUT_KEY_RIGHT -> cmdAdd "-Right" 
	| GLUT_KEY_DOWN  -> cmdAdd "-Down"
	| _ -> ()


    let keyboard key x y =
      match key with
	| 'x'    -> cmdAdd "fire"
	| '\027' -> activeScreen := Menu
	| ' '    -> glutPostRedisplay ()
	| '\009' -> Hud.scoreTableActive := true
	| _ -> ()

    let keyboardUp key x y =
      match key with
	| '\027' -> activeScreen := Menu
	| ' ' -> glutPostRedisplay ()
	| '\009' -> Hud.scoreTableActive := false
	| _ -> ()

    let draw () =
      if not !connected then () else
      let () = match objects () with
	| Types.Data.List ls -> List.iter Object.draw ls
	| _ -> assert false in 
      let () = match players () with
	| Types.Data.List ls -> List.iter Player.draw ls
	| _ -> assert false in
      Hud.draw ()
  end


module Menus =
  struct
    (* to add a new menu add a new constructor below 
       and modify the getActive function. 
       The new menu module has to conform to the MENU specification *)
    type menus = MainMenu | PauseMenu | ConnectMenu

    module type MENU = 
      sig
	val up: unit -> unit
	val down: unit -> unit
        val action: unit -> unit
	val keyboard: char -> int -> int -> unit
	val draw: unit -> unit
      end

    let bgColor = (1.0, 1.0, 1.0, 0.2)
    let selColor = (0.8, 0.8, 0.8, 0.2)
    let textColor = (1.0, 1.0, 1.0, 1.0)
    let font = GLUT_BITMAP_HELVETICA_10

    let activeMenu = ref MainMenu
    let activate menu = activeMenu := menu
    let drawMenu = Widgets.menu bgColor selColor textColor font
      
    module Main =
      struct
	let selected = ref 0
	let items = 
	  List.map Types.Data.of_string ["Connect to a server";"Exit"]
	let nItems = List.length items

	let up () = selected := max 0 (!selected - 1)
	let down () = selected := min (nItems-1) (!selected + 1)

        let action () =
	  match !selected with
	    | 0 -> activate ConnectMenu
	    | 1 -> let () = Client.finalize () in exit 0
	    | _ -> ()

	let keyboard key x y =
	  match key with
	    | '\027' -> activeScreen := Game
	    | '\013' -> action() 
	    | _ -> ()

	let draw () =
	  if !Client.connected then activate PauseMenu else
	    drawMenu items !selected
      end  
      
    module Pause =
      struct
	let selected = ref 0
	let items = 
	  List.map Types.Data.of_string ["Connect to a server";"Disconnect";
					 "Return to game";"Exit"]
	let nItems = List.length items

	let up () = selected := max 0 (!selected - 1)
	let down () = selected := min (nItems-1) (!selected + 1)

        let action () =
	  match !selected with
	    | 0 -> activate ConnectMenu
	    | 1 -> let () = Client.finalize () in activate MainMenu
 	    | 2 -> activeScreen := Game
	    | 3 -> let () = Client.finalize () in exit 0
	    | _ -> ()

	let keyboard key x y =
	  match key with
	    | '\027' -> activeScreen := Game
	    | '\013' -> action() 
	    | _ -> ()

	let draw () = drawMenu items !selected
      end  

    module Connect =
      struct
	let selected = ref 0
	let items = 
	  List.map Types.Data.of_string ["Server: ___________";"Back"]
	let nItems = List.length items
	let buf = ref ""
 
	let up () = selected := max 0 (!selected - 1)
	let down () = selected := min (nItems-1) (!selected + 1)
        let buffer c = buf := !buf^c; ()
	let del () = 
	  let len = String.length !buf in
	  if len = 0 then () else buf := String.sub !buf 0 (len-1)
      
	let action () =
	  match !selected with
	    | 0 -> (try
		       Client.openConnection !buf (Config.portNumber);
		       activate PauseMenu; activeScreen := Game;
                    with _ -> ()) (* TODO: add fancy error messages *)
	    | 1 -> if !Client.connected then activate PauseMenu
	           else activate MainMenu
	    | _ -> ()

	let keyboard key x y =
	  match key with
	    | '\027' -> if !Client.connected then activate PauseMenu
	                else activate MainMenu
	    | '\013' -> action() 
	    | '0' .. '9' |'A' .. 'Z' | 'a' .. 'z' | '.' -> 
	      if !selected = 0 then buffer (String.make 1 key) else ()
	    | '\008' -> del ()
	    | _ -> ()

	let draw () = 
	  match items with
	    | (Types.Data.String s)::ss -> 
	        let serverString = if !buf <> "" then
		    (String.sub s 0 8)^(!buf) else s in
		drawMenu ((Types.Data.String serverString)::ss) !selected
	    | _ -> ()
      end 

    let getActive () = (* uses first-class modules, requires Ocaml 3.12 *)
      if !activeScreen = Menu then
	match !activeMenu with
	  | MainMenu -> (module Main: MENU)
	  | PauseMenu -> (module Pause: MENU)
	  | ConnectMenu -> (module Connect: MENU)
      else assert false

    let draw () = 
      if !activeScreen = Menu then
	let module Active = (val (getActive ()): MENU) in
	  Active.draw ()
      else ()

    let keyboard key x y =
      let module Active = (val (getActive ()): MENU) in
      Active.keyboard key x y
      
    let special ~key ~x ~y = 
      let module Active = (val (getActive ()): MENU) in 
      match key with
	| GLUT_KEY_DOWN    -> Active.down ()
	| GLUT_KEY_UP  -> Active.up ()
	| _ -> ()
  end 

(* refresh rate in milliseconds *)
let timerTicks = 40

(* update display *)
let display () = 
    glClear [GL_COLOR_BUFFER_BIT];
    glBegin GL_LINE_LOOP;
    glColor4 1.0 1.0 1.0 1.0;
    glVertex2 (1.0) (1.0);
    glVertex2 (1.0) (0.0);
    glVertex2 (0.0) (0.0);
    glVertex2 (0.0) (1.0);
    glEnd ();
    Client.draw ();
    Menus.draw ();
    (* refresh display buffers *)
    glutSwapBuffers ()

let keyboard ~key ~x ~y = 
  begin match !activeScreen with
    | Game -> Client.keyboard key x y
    | Menu -> Menus.keyboard key x y
  end

let keyboardUp ~key ~x ~y = 
  begin match !activeScreen with
    | Game -> Client.keyboardUp key x y
    | _ -> ()
  end

let special ~key ~x ~y =
  begin match !activeScreen with
    | Game -> Client.special key x y
    | Menu -> Menus.special key x y
  end


let specialUp ~key ~x ~y = 
  begin match !activeScreen with
    | Game -> Client.specialUp key x y
    | _ -> ()
  end


(* called every timerTicks *)
let rec timer ~value = 
    glutTimerFunc timerTicks timer 0;
    glutPostRedisplay ();
    Client.updateState ();
    ()

(* on window geometry change *)
let reshape ~width ~height = 
    glViewport 0 0 width height;
    glMatrixMode GL_PROJECTION;
    glLoadIdentity ();
    let length = float (min width height) in
    let fwidth = float width /. length in
    let fheight = float height /. length in
    glOrtho 0.0 fwidth 0.0 fheight (-1.0) (1.0);
    glTranslate (fwidth /. 2.0 -. 0.5) (fheight /. 2.0 -. 0.5) 0.0;
    glMatrixMode GL_MODELVIEW;
    ()

(* init OpenGL library *)
let initGL () = 
    glClearColor 0.0 0.0 0.0 1.0;
    glShadeModel GL_FLAT;
    glPointSize 2.5;
    glEnable GL_BLEND;
    glBlendFunc Sfactor.GL_SRC_ALPHA Dfactor.GL_ONE_MINUS_SRC_ALPHA;
    glHint GL_LINE_SMOOTH_HINT GL_DONT_CARE;
    glHint GL_POINT_SMOOTH_HINT GL_DONT_CARE;
    reshape 800 600;
    ()

(* init glut window *)
let initGlut () = 
    ignore (glutInit Sys.argv);
    glutInitDisplayMode [GLUT_DOUBLE; GLUT_RGBA];
    glutInitWindowSize 800 600;
    ignore (glutCreateWindow "gra");
    initGL ();
    glutDisplayFunc ~display;
    glutReshapeFunc ~reshape;
    glutKeyboardFunc ~keyboard;
    glutKeyboardUpFunc keyboardUp;
    glutSpecialFunc ~special;
    glutSpecialUpFunc specialUp;
    glutTimerFunc timerTicks timer 0;
    ()

let usage () =
  Printf.printf "Usage: client [-s SERVERNAME]\n"

let parseArgs () =
  let argNumber = Array.length Sys.argv in
  for i = 1 to argNumber-1 do
    match Sys.argv.(i) with
      | "-s" ->
        if i+1=argNumber then (usage (); exit 0)
	else 
	  Client.openConnection (Sys.argv.(i+1)) (Config.portNumber);
	  activeScreen := Game
      | _ -> ()
   done


(* entry point *)
let main () = 
    parseArgs ();
    initGlut ();
    glutMainLoop ();
    ()

let () = main ()

